VERSION 5.00
Begin VB.Form frmTest 
   Caption         =   "ErrorHandler Tester"
   ClientHeight    =   8955
   ClientLeft      =   120
   ClientTop       =   450
   ClientWidth     =   9090
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   ScaleHeight     =   8955
   ScaleWidth      =   9090
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton cmdRecursion 
      Caption         =   "Recursive"
      Height          =   615
      Left            =   360
      TabIndex        =   21
      Top             =   3240
      Width           =   1455
   End
   Begin VB.CommandButton cmdMultipleClass2 
      Caption         =   "Multiple Class Error"
      Height          =   615
      Left            =   4440
      TabIndex        =   18
      Top             =   1080
      Width           =   1455
   End
   Begin VB.CommandButton cmdMultipleClassAndSub2 
      Caption         =   "Multiple Class and Sub"
      Height          =   615
      Left            =   4440
      TabIndex        =   17
      Top             =   2520
      Width           =   1455
   End
   Begin VB.CommandButton cmdMultipleClassAndSub1 
      Caption         =   "Multiple Class and Sub"
      Height          =   615
      Left            =   2160
      TabIndex        =   15
      Top             =   2520
      Width           =   1455
   End
   Begin VB.CommandButton cmdMultipleClass1 
      Caption         =   "Multiple Class Error"
      Height          =   615
      Left            =   2160
      TabIndex        =   14
      Top             =   1080
      Width           =   1455
   End
   Begin VB.CommandButton cmdMultipleSubAndClassError 
      Caption         =   "Multiple Class and Sub"
      Height          =   615
      Left            =   360
      TabIndex        =   11
      Top             =   2520
      Width           =   1455
   End
   Begin VB.CommandButton cmdMultipleSubError 
      Caption         =   "Multiple Sub Error"
      Height          =   615
      Left            =   360
      TabIndex        =   10
      Top             =   1800
      Width           =   1455
   End
   Begin VB.CommandButton cmdMultipleClassError 
      Caption         =   "Multiple Class Error"
      Height          =   615
      Left            =   360
      TabIndex        =   9
      Top             =   1080
      Width           =   1455
   End
   Begin VB.ListBox lstOutput 
      Height          =   4350
      Left            =   240
      TabIndex        =   4
      Top             =   4080
      Width           =   8535
   End
   Begin VB.Frame fmeCancel 
      Caption         =   "Main Class Interface Handling"
      Height          =   2775
      Left            =   6360
      TabIndex        =   1
      Top             =   480
      Width           =   2415
      Begin VB.CheckBox chkCancelClassRemove 
         Caption         =   "Class Remove"
         Height          =   495
         Left            =   360
         TabIndex        =   8
         Top             =   2160
         Width           =   1695
      End
      Begin VB.CheckBox chkCancelMethodRemove 
         Caption         =   "Method Remove"
         Height          =   495
         Left            =   360
         TabIndex        =   7
         Top             =   1800
         Width           =   1695
      End
      Begin VB.CheckBox chkCancelMethodAdd 
         Caption         =   "Method Add"
         Height          =   495
         Left            =   360
         TabIndex        =   6
         Top             =   1080
         Width           =   1695
      End
      Begin VB.CheckBox chkCancelClassAdd 
         Caption         =   "Class Add"
         Height          =   495
         Left            =   360
         TabIndex        =   5
         Top             =   1440
         Width           =   1695
      End
      Begin VB.CheckBox chkCancelDisplayMessage 
         Caption         =   "Display Message"
         Height          =   495
         Left            =   240
         TabIndex        =   3
         Top             =   720
         Width           =   1695
      End
      Begin VB.CheckBox chkCancelMessageStream 
         Caption         =   "Error Stream"
         Height          =   495
         Left            =   240
         TabIndex        =   2
         Top             =   360
         Width           =   1215
      End
   End
   Begin VB.CommandButton cmdSingleSubError 
      Caption         =   "Single sub error"
      Height          =   615
      Left            =   360
      TabIndex        =   0
      Top             =   360
      Width           =   1455
   End
   Begin VB.Label lblMultiple2Description 
      Caption         =   "errorAdded, classAdded, methodAdded Centralization"
      Height          =   735
      Left            =   4320
      TabIndex        =   20
      Top             =   240
      Width           =   1815
   End
   Begin VB.Label lblMultiple2 
      AutoSize        =   -1  'True
      Caption         =   "Multiple Error Handler"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   195
      Left            =   4320
      TabIndex        =   19
      Top             =   0
      Width           =   1860
   End
   Begin VB.Label lblMultiple1Description 
      Caption         =   "errorAdded Centralization"
      Height          =   255
      Left            =   2040
      TabIndex        =   16
      Top             =   240
      Width           =   1815
   End
   Begin VB.Label lblMultipleErrorHandler 
      AutoSize        =   -1  'True
      Caption         =   "Multiple Error Handler"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   195
      Left            =   2040
      TabIndex        =   13
      Top             =   0
      Width           =   1860
   End
   Begin VB.Label lblSingleHandler 
      AutoSize        =   -1  'True
      Caption         =   "Single Error Handler"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   195
      Left            =   120
      TabIndex        =   12
      Top             =   0
      Width           =   1725
   End
End
Attribute VB_Name = "frmTest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Implements IErrorClassRegListener
Implements IErrorMethodRegListener
Implements IErrorOpsCallback
Implements IErrorListener


Private Const CM_INITMETHODNAME = "init"

Private vm_errorClass As ErrorClass

'An error handler for testing - some subs will use mainErrorHandler, and
'others will use this one. This is the "universal" variable name for
'the module-level error handler used by the MZ-Tools error handler
'code.
Private vm_ErrorHandler As TrappableErrorHandler

Private Sub cmdMultipleClass1_Click()

'Beginning of Auto-Generated Error Handler
Dim vl_zErrorMethod As errormethod
Set vl_zErrorMethod = vm_ErrorHandler.createNewChildErrorMethod("cmdMultipleClass1_Click", vm_errorClass)

   On Error GoTo cmdMultipleClass1_Click_Error
'End of Auto-Generated Error Handler
Const CL_ERROR = "There was some error that occured in frmTest_clickevent."

Dim vl_TestClass As clsObjToTest
Set vl_TestClass = New clsObjToTest

vl_TestClass.testMethodWithDescriptionLine
If vm_ErrorHandler.errorExists Then
    vl_zErrorMethod.registerErrorByDescription CL_ERROR
    vm_ErrorHandler.displayErrorsAndClear
End If

Set vl_TestClass = Nothing

'Beginning of Auto-Generated Error Handler
   On Error GoTo 0
cleanUp:
   vm_ErrorHandler.unregisterAndReturnErrorMethodByName "cmdMultipleClass1_Click"
   Set vl_zErrorMethod = Nothing
   Exit Sub

cmdMultipleClass1_Click_Error:

vl_zErrorMethod.registerInternalErrorByObjectAtLine Err, Erl
'End of Auto-Generated Error Handler
End Sub

Private Sub cmdMultipleClassAndSub1_Click()

'Beginning of Auto-Generated Error Handler
Dim vl_zErrorMethod As errormethod
Set vl_zErrorMethod = vm_ErrorHandler.createNewChildErrorMethod("cmdMultipleClassAndSub1_Click", vm_errorClass)

   On Error GoTo cmdMultipleClassAndSub1_Click_Error
'End of Auto-Generated Error Handler

Const CL_ERROROCCURED As String = "An error occured in the testing of multiple classes and multiple subs."

Dim vl_TestObj As clsObjToTest
Set vl_TestObj = New clsObjToTest

vl_TestObj.testMultipleMethods
If vm_ErrorHandler.errorExists Then
    vl_zErrorMethod.registerErrorByDescription CL_ERROROCCURED
    vm_ErrorHandler.displayErrorsAndClear
End If


Set vl_TestObj = Nothing
    

'Beginning of Auto-Generated Error Handler
   On Error GoTo 0
cleanUp:
   vm_ErrorHandler.unregisterAndReturnErrorMethodByName "cmdMultipleClassAndSub1_Click"
   Set vl_zErrorMethod = Nothing
   Exit Sub

cmdMultipleClassAndSub1_Click_Error:

vl_zErrorMethod.registerInternalErrorByObjectAtLine Err, Erl
'End of Auto-Generated Error Handler
End Sub

Private Sub cmdMultipleClassError_Click()
Dim vl_ErrorMethod As errormethod
Set vl_ErrorMethod = mainErrorHandler.createNewChildErrorMethod("cmdMultipleClassError", vm_errorClass)

Const CL_ERROROCCURED As String = "An error occured while clicking a button."


Dim vl_NewClass As clsObjToTest

Set vl_NewClass = New clsObjToTest
Set vl_NewClass.ErrorHandler = mainErrorHandler
vl_NewClass.testMethodWithDescriptionLine
appendWrapperErrorByDescriptionAndDisplayOption mainErrorHandler, CL_ERROROCCURED, vl_ErrorMethod, True


mainErrorHandler.unregisterAndReturnErrorMethodByName "cmdMultipleClassError"
Set vl_ErrorMethod = Nothing
End Sub







Private Sub cmdMultipleSubAndClassError_Click()

Dim vl_ErrorMethod As errormethod
Set vl_ErrorMethod = vm_ErrorHandler.createNewChildErrorMethod("cmdMultipleSubAndClassError_Click", vm_errorClass)

   On Error GoTo cmdMultipleSubAndClassError_Click_Error

    Dim vl_TestClass As clsObjToTest
    Set vl_TestClass = New clsObjToTest
    
    Set vl_TestClass.ErrorHandler = vm_ErrorHandler
    vl_TestClass.testMultipleMethods
    appendWrapperErrorByDescriptionAndDisplayOption vm_ErrorHandler, _
            "An error occured after clicking MultipleClassSub", vl_ErrorMethod, True
    
    
    Set vl_TestClass = Nothing

   On Error GoTo 0
cleanUp:
   vm_ErrorHandler.unregisterAndReturnErrorMethodByName "cmdMultipleSubAndClassError_Click"
   Set vl_ErrorMethod = Nothing
   Exit Sub

cmdMultipleSubAndClassError_Click_Error:

vl_ErrorMethod.registerInternalErrorByObjectAtLine Err, Erl
End Sub

Private Sub cmdMultipleSubError_Click()
Dim vl_ErrorMethod As errormethod
Set vl_ErrorMethod = mainErrorHandler.createNewChildErrorMethod("cmdMultipleSubError_Click", vm_errorClass)

Const CL_FAKERROR As String = "This is the topmost error description."

multipleSubTest mainErrorHandler
appendWrapperErrorByDescriptionAndDisplayOption mainErrorHandler, CL_FAKERROR, vl_ErrorMethod, True

'Keep this for testing use
 mainErrorHandler.unregisterAndReturnErrorMethodByName "cmdMultipleSubError_Click"
Set vl_ErrorMethod = Nothing
End Sub

Private Sub cmdRecursion_Click()

'Beginning of Auto-Generated Error Handler
Dim vl_ErrorMethod As errormethod
Set vl_ErrorMethod = vm_ErrorHandler.createNewChildErrorMethod("cmdRecursion_Click", vm_errorClass)

   On Error GoTo cmdRecursion_Click_Error
'End of Auto-Generated Error Handler

    Dim vl_TestClass As clsObjToTest
    Set vl_TestClass = New clsObjToTest
    
    Set vl_TestClass.ErrorHandler = vm_ErrorHandler
    vl_TestClass.recursiveTest 5
    appendWrapperErrorByDescriptionAndDisplayOption vm_ErrorHandler, _
            "An error occured after clicking Recursive", vl_ErrorMethod, True
    
    
    Set vl_TestClass = Nothing

 
    

'Beginning of Auto-Generated Error Handler
   On Error GoTo 0
cleanUp:
   vm_ErrorHandler.unregisterAndReturnErrorMethodByName "cmdRecursion_Click"
   Set vl_ErrorMethod = Nothing
   Exit Sub

cmdRecursion_Click_Error:

vl_ErrorMethod.registerInternalErrorByObjectAtLine Err, Erl
'End of Auto-Generated Error Handler
End Sub

Private Sub cmdSingleSubError_Click()
Dim vl_ErrorMethod As errormethod
Set vl_ErrorMethod = mainErrorHandler.createNewChildErrorMethod("cmdSingleSubError_Click", vm_errorClass)


vl_ErrorMethod.registerErrorByDescription "This is a test description"
If mainErrorHandler.errorExists Then mainErrorHandler.displayErrorsAndClear


'Keep this for testing use
 mainErrorHandler.unregisterAndReturnErrorMethodByName "cmdSingleSubError_Click"
Set vl_ErrorMethod = Nothing
End Sub



Private Sub Form_Initialize()
initializeErrorHandler

Set vm_ErrorHandler = mainErrorHandler

With vm_ErrorHandler
    .addErrorRegistrationListener Me
    .addOperationsListener Me
    .addMethodRegistrationListener Me
    .addClassRegistrationListener Me
End With


Set vm_errorClass = mainErrorHandler.createNewChildErrorClass(Me.Name)
mainErrorHandler.createNewChildErrorMethod CM_INITMETHODNAME, vm_errorClass
End Sub


Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
mainErrorHandler.unregisterAndReturnErrorMethodByName CM_INITMETHODNAME
mainErrorHandler.unregisterAndReturnErrorClassByName Me.Name
End Sub

Private Sub addNewLogItem(ByVal pr_ItemToAdd As String)
lstOutput.AddItem Format(DateTime.Now, "Long Time") & ": " & pr_ItemToAdd, 0
End Sub

Private Sub Form_Terminate()
With vm_ErrorHandler
    .removeErrorRegistrationListener Me
    .removeOperationsRegistrationListener Me
    .removeMethodRegistrationListener Me
    .removeClassRegistrationListener Me
End With

Set vm_ErrorHandler = Nothing
End Sub



Private Sub Form_Resize()
lstOutput.Height = Me.ScaleHeight - lstOutput.Top - 200
End Sub









Private Sub IErrorClassRegListener_afterClassAdded(ByVal classAdded As VBErrorHandler.ErrorClass)
addNewLogItem "IErrorClassRegListener_afterClassAdded: " & classAdded.className
End Sub

Private Sub IErrorClassRegListener_afterClassRemoved(ByVal classRemoved As VBErrorHandler.ErrorClass)
addNewLogItem "IErrorClassRegListener_afterClassRemoved: " & classRemoved.className
End Sub

Private Sub IErrorClassRegListener_beforeClassAddedCancelOpprotunity(ByVal classToAdd As VBErrorHandler.ErrorClass, ByVal Cancel As VBErrorHandler.CancelArg)
addNewLogItem "IErrorClassRegListener_beforeClassAddedCancelOpprotunity: " & classToAdd.className
End Sub

Private Sub IErrorClassRegListener_beforeClassRemovedCancelOpprotunity(ByVal classToRemove As VBErrorHandler.ErrorClass, ByVal Cancel As VBErrorHandler.CancelArg)
addNewLogItem "IErrorClassRegListener_beforeClassRemovedCancelOpprotunity: " & classToRemove.className
End Sub


Private Sub IErrorListener_errorCleared(ByVal firstError As VBErrorHandler.ErrorNode)
addNewLogItem "IErrorListener_errorCleared: " & firstError.stackTrace
End Sub

Private Sub IErrorMethodRegListener_afterMethodAdded(ByVal methodToAdd As VBErrorHandler.errormethod)
addNewLogItem "IErrorMethodRegListener_afterMethodAdded: " & methodToAdd.methodName
End Sub

Private Sub IErrorMethodRegListener_afterMethodRemoved(ByVal methodRemoved As VBErrorHandler.errormethod)
addNewLogItem "IErrorMethodRegListener_afterMethodRemoved: " & methodRemoved.methodName
End Sub

Private Sub IErrorMethodRegListener_beforeMethodAddedCancelOpprotunity(ByVal methodToAdd As VBErrorHandler.errormethod, ByVal Cancel As VBErrorHandler.CancelArg)
addNewLogItem "IErrorMethodRegListener_beforeMethodAddedCancelOpprotunity: " & methodToAdd.methodName
Cancel = (chkCancelMethodAdd.Value = vbChecked)
End Sub

Private Sub IErrorMethodRegListener_beforeMethodRemovedCancelOpprotunity(ByVal methodToRemove As VBErrorHandler.errormethod, ByVal Cancel As VBErrorHandler.CancelArg)
addNewLogItem "IErrorMethodRegListener_beforeMethodRemovedCancelOpprotunity: " & methodToRemove.methodName
Cancel = (chkCancelClassAdd.Value = vbChecked)
End Sub

Private Sub IErrorOpsCallback_afterDisplayErrorContinueProgram(ByVal displayData As VBErrorHandler.DataToDisplay)
addNewLogItem "afterDisplayErrorContinueProgram"
End Sub

Private Sub IErrorOpsCallback_afterDisplayErrorEndProgram(ByVal displayData As VBErrorHandler.DataToDisplay)
addNewLogItem "afterDisplayEndProgram"
Unload Me
End Sub

Private Sub IErrorOpsCallback_beforeDisplayErrorCancelOpprotunity(ByVal displayData As VBErrorHandler.DataToDisplay, ByVal Cancel As CancelArg)
addNewLogItem "beforeDisplayErrorCancelOpprotunity"

Cancel = (chkCancelDisplayMessage.Value = vbChecked)
End Sub

Private Sub IErrorOpsCallback_ProcessingError(errorDetails As VBErrorHandler.ErrorNode)
addNewLogItem "ProcessingError"
End Sub



Private Sub IErrorOpsCallback_beforePushErrorStackCancelOpprotunity(ByVal errorToAdd As VBErrorHandler.ErrorNode, ByVal Cancel As CancelArg)
addNewLogItem "beforePushErrorStack"
Cancel = (chkCancelMessageStream.Value = vbChecked)
End Sub

Private Sub IErrorListener_errorAdded(ByVal newError As VBErrorHandler.ErrorNode)
If newError.faultClass Is Nothing Then
    addNewLogItem "errorAdded: " & newError.Description & vbTab & "Method: " & newError.faultMethod.methodName
Else
    addNewLogItem "errorAdded: " & newError.Description & vbTab & "Method: " & newError.faultMethod.methodName _
                & vbTab & "Class: " & newError.faultClass.className
End If
End Sub

Private Sub IErrorOpsCallback_beforePopErrorStackCancelOpprotunity(ByVal currentErrorStack As VBVariantStack.Stack, ByVal Cancel As CancelArg)
addNewLogItem "beforePopErrorStack"
End Sub

